home *** CD-ROM | disk | FTP | other *** search
/ Scene 96 / Scene 96 International Edition (Zyklop Software) (Disc 2) (1997).iso / misc / coding / vgacodng / part08_d.pas < prev    next >
Pascal/Delphi Source File  |  1996-11-22  |  2KB  |  73 lines
  1. {$N+,E+}
  2. program Fraktale;
  3.  
  4. uses crt;
  5.  
  6. { Diese Konstanten können verändert werden, um das Aussehen der Fraktale zu
  7.   bestimmen. }
  8. const Colors = 32;         { Anzahl der Farben des Fraktals }
  9.       Width = 320;         { Breite des Fraktals }
  10.       Height = 200;        { Höhe des Fraktals }
  11.       Limit = 8.0;         { Berechnungsgrenze, regelt Schärfe }
  12.       XRMin = -2.0;        { Linke Grenze des Fraktals }
  13.       XRMax = 1.0;         { Rechte Grenze des Fraktals }
  14.       YRMin = -1.3;        { Obere Grenze des Fraktals }
  15.       YRMax = 1.3;         { Untere Grenze des Fraktals }
  16.  
  17. type real = double;        { Zur Optimierung der Fließkomma-Berechnungen }
  18.  
  19. var XPos,YPos : word;
  20.     RealP,ImagP : real;
  21.     CurrX,CurrY : real;
  22.     a2,b2 : real;
  23.     n : byte;
  24.  
  25. function CalcColorMandel(XPos,YPos:word) : byte;
  26. begin
  27.   CurrX := XPos / Width * (XRMax-XRMin) + XRMin;
  28.   CurrY := YPos / Height * (YRMax-YRMin) + YRMin;
  29.   RealP := 0;
  30.   ImagP := 0;
  31.   n := 0;
  32.   repeat
  33.     a2 := sqr(RealP);
  34.     b2 := sqr(ImagP);
  35.     ImagP := 2 * RealP * ImagP + CurrY;
  36.     RealP := a2 - b2 + CurrX;
  37.     inc(n);
  38.   until (n >= Colors) or (a2+b2 >= Limit);
  39.   CalcColorMandel := n - 1;
  40. end;
  41.  
  42. function CalcColorJulia(XPos,YPos:word) : byte;
  43. begin
  44.   CurrX := 0.07;
  45.   CurrY := -0.4;
  46.   RealP := -2 + 0.5 + XPos / (Width/3);
  47.   ImagP := 2 - 0.5 - YPos / (Height/3);
  48.   n := 0;
  49.   repeat
  50.     a2 := sqr(ImagP) - sqr(RealP) + CurrX;
  51.     b2 := 2 * RealP * ImagP + CurrY;
  52.     RealP := a2;
  53.     ImagP := b2;
  54.     inc(n);
  55.   until (n >= Colors) or (sqr(a2)+sqr(b2) > 4) or
  56.         (abs(a2) > 2) or (abs(b2) > 2);
  57.   CalcColorJulia := n - 1;
  58. end;
  59.  
  60.  
  61. begin
  62.   asm mov ax,13h; int 10h end;   { In Mode 13h schalten }
  63.   for YPos := 0 to Height-1 do   { Mandelbrot-Menge aufbauen }
  64.     for XPos := 0 to Width-1 do
  65.       mem[$A000:YPos*320+XPos] := CalcColorMandel(XPos,YPos);
  66.   readkey;
  67.   for YPos := 0 to Height-1 do   { Julia-Menge aufbauen }
  68.     for XPos := 0 to Width-1 do
  69.       mem[$A000:YPos*320+XPos] := CalcColorJulia(XPos,YPos);
  70.   readkey;
  71.   asm mov ax,3; int 10h end;     { Zurück zum Textmodus }
  72. end.
  73.